home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / Utility.cls < prev    next >
Text File  |  1997-06-14  |  28KB  |  914 lines

  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "GUtility"
  6. Attribute VB_GlobalNameSpace = True
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = True
  10. Option Explicit
  11.  
  12. Public Enum EHexDump
  13.     ehdOneColumn
  14.     ehdTwoColumn
  15.     ehdEndless
  16.     ehdSample8
  17.     ehdSample16
  18. End Enum
  19.  
  20. Enum ESearchOptions
  21.     esoCaseSense = &H1
  22.     esoBackward = &H2
  23.     esoWholeWord = &H4
  24. End Enum
  25.  
  26. Public Enum EErrorUtility
  27.     eeBaseUtility = 13000   ' Utility
  28.     eeNoMousePointer        ' HourGlass: Object doesn't have mouse pointer
  29.     eeNoTrueOption          ' GetOption: None of the options are True
  30.     eeNotOptionArray        ' GetOption: Not control array of OptionButton
  31.     eeMissingParameter      ' InStrR: One or more parameters are missing
  32. End Enum
  33.  
  34. #If fComponent Then
  35. Private Sub Class_Initialize()
  36.     ' Seed sequence with timer for each client
  37.     Randomize
  38. End Sub
  39. #End If
  40.  
  41. #If fComponent = 0 Then
  42. Private Sub ErrRaise(e As Long)
  43.     Dim sText As String, sSource As String
  44.     If e > 1000 Then
  45.         sSource = App.ExeName & ".Utility"
  46.         Select Case e
  47.         Case eeBaseUtility
  48.             BugAssert True
  49.         Case eeNoMousePointer
  50.             sText = "HourGlass: Object doesn't have mouse pointer"
  51.         Case eeNoTrueOption
  52.             sText = "GetOption: None of the options are True"
  53.         Case eeNotOptionArray
  54.             sText = "GetOption: Argument is not a control array" & _
  55.                     "of OptionButtons"
  56.         Case eeMissingParameter
  57.             sText = "InStrR: One or more parameters are missing"
  58.         End Select
  59.         Err.Raise COMError(e), sSource, sText
  60.     Else
  61.         ' Raise standard Visual Basic error
  62.         sSource = App.ExeName & ".VBError"
  63.         Err.Raise e, sSource
  64.     End If
  65. End Sub
  66. #End If
  67.  
  68. ' Can't do sNullChr in type library, so fake it here
  69. Public Property Get sNullChr() As String
  70.     sNullChr = vbNullChar
  71. End Property
  72.  
  73. Sub HourGlass(obj As Object)
  74.     Static ordMouse As Integer, fOn As Boolean
  75.     On Error Resume Next
  76.     If Not fOn Then
  77.         ' Save pointer and set hourglass
  78.         ordMouse = obj.MousePointer
  79.         obj.MousePointer = vbHourglass
  80.         fOn = True
  81.     Else
  82.         ' Restore pointer
  83.         obj.MousePointer = ordMouse
  84.         fOn = False
  85.     End If
  86.     If Err Then ErrRaise eeNoMousePointer
  87. End Sub
  88.  
  89. Function IsArrayEmpty(va As Variant) As Boolean
  90.     Dim v As Variant
  91.     On Error Resume Next
  92.     v = va(LBound(va))
  93.     IsArrayEmpty = (Err <> 0)
  94. End Function
  95.  
  96. Function HasShell() As Boolean
  97.     Dim dw As Long
  98.     dw = GetVersion()
  99.     If (dw And &HFF&) >= 4 Then
  100.         HasShell = True
  101.         ' Proves that operating system has shell, but not
  102.         ' necessarily that it is installed. Some might argue
  103.         ' that this function should check Registry under WinNT
  104.         ' or SYSTEM.INI Shell= under Win95
  105.     End If
  106. End Function
  107.  
  108. Function IsNT() As Boolean
  109.     Dim dw As Long
  110.     IsNT = ((GetVersion() And &H80000000) = 0)
  111. End Function
  112.  
  113. Sub SwapBytes(ByVal b1 As Byte, ByVal b2 As Byte)
  114.     Dim bTmp As Byte
  115.     b1 = bTmp
  116.     b2 = b1
  117.     b1 = bTmp
  118. End Sub
  119.  
  120. Sub SwapIntegers(ByVal w1 As Integer, ByVal w2 As Integer)
  121.     Dim wTmp As Byte
  122.     w1 = wTmp
  123.     w2 = w1
  124.     w1 = wTmp
  125. End Sub
  126.  
  127. Sub SwapLongs(ByVal dw1 As Long, ByVal dw2 As Long)
  128.     Dim dwTmp As Byte
  129.     dw1 = dwTmp
  130.     dw2 = dw1
  131.     dw1 = dwTmp
  132. End Sub
  133.  
  134. Function FmtHex(ByVal i As Long, _
  135.                 Optional ByVal iWidth As Integer = 8) As String
  136.     FmtHex = Right$(String$(iWidth, "0") & Hex$(i), iWidth)
  137. End Function
  138.  
  139. Function FmtInt(ByVal iVal As Integer, ByVal iWidth As Integer, _
  140.                 Optional fRight As Boolean = True) As String
  141.     If fRight Then
  142.         FmtInt = Right$(Space$(iWidth) & iVal, iWidth)
  143.     Else
  144.         FmtInt = Left$(iVal & Space$(iWidth), iWidth)
  145.     End If
  146. End Function
  147.  
  148. Function FmtStr(s As String, ByVal iWidth As Integer, _
  149.                 Optional fRight As Boolean = True) As String
  150.     If fRight Then
  151.         FmtStr = Left$(s & Space$(iWidth), iWidth)
  152.     Else
  153.         FmtStr = Right$(Space$(iWidth) & s, iWidth)
  154.     End If
  155. End Function
  156.  
  157. ' Find the True option from a control array of OptionButtons
  158. Function GetOption(opts As Object) As Integer
  159.     On Error GoTo GetOptionFail
  160.     Dim opt As OptionButton
  161.     For Each opt In opts
  162.         If opt.Value Then
  163.             GetOption = opt.Index
  164.             Exit Function
  165.         End If
  166.     Next
  167.     On Error GoTo 0
  168.     ErrRaise eeNoTrueOption
  169.     Exit Function
  170. GetOptionFail:
  171.     ErrRaise eeNotOptionArray
  172. End Function
  173.  
  174. ' Make sure path ends in a backslash
  175. Function NormalizePath(sPath As String) As String
  176.     If Right$(sPath, 1) <> sBSlash Then
  177.         NormalizePath = sPath & sBSlash
  178.     Else
  179.         NormalizePath = sPath
  180.     End If
  181. End Function
  182.  
  183. ' Make sure path doesn't end in a backslash
  184. Sub DenormalizePath(sPath As Variant)
  185.     If Right$(sPath, 1) = sBSlash Then
  186.         sPath = Left$(sPath, Len(sPath) - 1)
  187.     End If
  188. End Sub
  189.  
  190. ' Test file existence with error trapping
  191. Function ExistFile(sSpec As String) As Boolean
  192.     On Error Resume Next
  193.     Call FileLen(sSpec)
  194.     ExistFile = (Err = 0)
  195. End Function
  196.  
  197. ' Test file existence with the Windows API
  198. Function ExistFileDir(sSpec As String) As Boolean
  199.     Dim af As Long
  200.     af = GetFileAttributes(sSpec)
  201.     ExistFileDir = (af <> -1)
  202. End Function
  203.  
  204. ' Test file existence with the Dir$ function
  205. Function Exists(sSpec As String) As Boolean
  206.     Exists = Dir$(sSpec, vbDirectory) <> sEmpty
  207. End Function
  208.  
  209. ' Convert Automation color to Windows color
  210. Function TranslateColor(ByVal clr As OLE_COLOR, _
  211.                         Optional hPal As Long = 0) As Long
  212.     If OleTranslateColor(clr, hPal, TranslateColor) Then
  213.         TranslateColor = CLR_INVALID
  214.     End If
  215. End Function
  216.  
  217. Function GetExtPos(sSpec As String) As Integer
  218.     Dim iLast As Integer, iExt As Integer
  219.     iLast = Len(sSpec)
  220.     
  221.     ' Parse backward to find extension or base
  222.     For iExt = iLast + 1 To 1 Step -1
  223.         Select Case Mid$(sSpec, iExt, 1)
  224.         Case "."
  225.             ' First . from right is extension start
  226.             Exit For
  227.         Case "\"
  228.             ' First \ from right is base start
  229.             iExt = iLast + 1
  230.             Exit For
  231.         End Select
  232.     Next
  233.  
  234.     ' Negative return indicates no extension, but this
  235.     ' is base so callers don't have to reparse.
  236.     GetExtPos = iExt
  237. End Function
  238.  
  239. Function GetFileText(sFileName As String) As String
  240.     Dim nFile As Integer, sText As String
  241.     nFile = FreeFile
  242.     'Open sFileName For Input As nFile ' Don't do this!!!
  243.     If Not ExistFile(sFileName) Then ErrRaise eeFileNotFound
  244.     ' Let others read but not write
  245.     Open sFileName For Binary Access Read Lock Write As nFile
  246.     ' sText = Input$(LOF(nFile), nFile) ! Don't do this!!!
  247.     ' This is much faster
  248.     sText = String$(LOF(nFile), 0)
  249.     Get nFile, 1, sText
  250.     Close nFile
  251.     GetFileText = sText
  252. End Function
  253.  
  254. Function IsRTF(sFileName As String) As Boolean
  255.     Dim nFile As Integer, sText As String
  256.     nFile = FreeFile
  257.     If Not ExistFile(sFileName) Then Exit Function
  258.     ' Pass error through to caller
  259.     Open sFileName For Binary Access Read Lock Write As nFile
  260.     If LOF(nFile) < 5 Then Exit Function
  261.     sText = String$(5, 0)
  262.     Get nFile, 1, sText
  263.     Close nFile
  264.     If sText = "{\rtf" Then IsRTF = True
  265. End Function
  266.  
  267. Function GetRandom(ByVal iLo As Long, ByVal iHi As Long) As Long
  268.     GetRandom = Int(iLo + (Rnd * (iHi - iLo + 1)))
  269. End Function
  270.  
  271. Sub DoWaitEvents(msWait As Long)
  272.     Dim msEnd As Long
  273.     msEnd = GetTickCount + msWait
  274.     Do
  275.         DoEvents
  276.     Loop While GetTickCount < msEnd
  277. End Sub
  278.  
  279. Function HexDumpS(s As String, Optional ehdFmt As EHexDump = ehdOneColumn) As String
  280.     Dim ab() As Byte
  281.     ab = StrToStrB(s)
  282.     HexDumpS = HexDump(ab, ehdFmt)
  283. End Function
  284.  
  285. Function HexDumpB(s As String, Optional ehdFmt As EHexDump = ehdOneColumn) As String
  286.     Dim ab() As Byte
  287.     ab = s
  288.     HexDumpB = HexDump(ab, ehdFmt)
  289. End Function
  290.  
  291. Function HexDumpPtr(ByVal p As Long, ByVal c As Long, _
  292.                     Optional ehdFmt As EHexDump = ehdOneColumn) As String
  293.     Dim ab() As Byte
  294.     ReDim ab(0 To c - 1) As Byte
  295.     CopyMemory ab(0), ByVal p, c
  296.     HexDumpPtr = HexDump(ab, ehdFmt)
  297. End Function
  298.  
  299. Function HexDump(ab() As Byte, _
  300.                  Optional ehdFmt As EHexDump = ehdOneColumn) As String
  301.     Dim i As Integer, sDump As String, sAscii As String
  302.     Dim iColumn As Integer, iCur As Integer, sCur As String
  303.     Dim sLine As String
  304.     Select Case ehdFmt
  305.     Case ehdOneColumn, ehdSample8
  306.         iColumn = 8
  307.     Case ehdTwoColumn, ehdSample16
  308.         iColumn = 16
  309.     Case ehdEndless
  310.         iColumn = 32767
  311.     End Select
  312.  
  313.     For i = LBound(ab) To UBound(ab)
  314.         ' Get current character
  315.         iCur = ab(i)
  316.         sCur = Chr$(iCur)
  317.  
  318.         ' Append its hex value
  319.         sLine = sLine & Right$("0" & Hex$(iCur), 2) & " "
  320.  
  321.         ' Append its ASCII value or dot
  322.         If ehdFmt <= ehdTwoColumn Then
  323.             If iCur >= 32 And iCur < 127 Then
  324.                 sAscii = sAscii & sCur
  325.             Else
  326.                 sAscii = sAscii & "."
  327.             End If
  328.         End If
  329.         
  330.         ' Append ASCII to dump and wrap every paragraph
  331.         If (i + 1) Mod 8 = 0 Then sLine = sLine & " "
  332.         If (i + 1) Mod iColumn = 0 Then
  333.             If ehdFmt >= ehdSample8 Then
  334.                 sLine = sLine & "..."
  335.                 Exit For
  336.             End If
  337.             sLine = sLine & " " & sAscii & sCrLf
  338.             sDump = sDump & sLine
  339.             sAscii = sEmpty
  340.             sLine = sEmpty
  341.         End If
  342.     Next
  343.     
  344.     If ehdFmt <= ehdTwoColumn Then
  345.         If (i + 1) Mod iColumn Then
  346.             If ehdFmt Then
  347.                 sLine = Left$(sLine & Space$(53), 53) & sAscii
  348.             Else
  349.                 sLine = Left$(sLine & Space$(26), 26) & sAscii
  350.             End If
  351.         End If
  352.         sDump = sDump & sLine
  353.     Else
  354.         sDump = sLine
  355.     End If
  356.     HexDump = sDump
  357.  
  358. End Function
  359.  
  360. Function StrToStrB(ByVal s As String) As String
  361.     If UnicodeTypeLib Then
  362.         StrToStrB = s
  363.     Else
  364.         StrToStrB = StrConv(s, vbFromUnicode)
  365.     End If
  366. End Function
  367.  
  368. Function StrBToStr(ByVal s As String) As String
  369.     If UnicodeTypeLib Then
  370.         StrBToStr = s
  371.     Else
  372.         StrBToStr = StrConv(s, vbUnicode)
  373.     End If
  374. End Function
  375.  
  376. Function StrZToStr(s As String) As String
  377.     StrZToStr = Left$(s, lstrlen(s))
  378. End Function
  379.  
  380. Function ExpandEnvStr(sData As String) As String
  381.     Dim c As Long, s As String
  382.     ' Get the length
  383.     s = sEmpty ' Needed to get around Windows 95 limitation
  384.     c = ExpandEnvironmentStrings(sData, s, c)
  385.     ' Expand the string
  386.     s = String$(c - 1, 0)
  387.     c = ExpandEnvironmentStrings(sData, s, c)
  388.     ExpandEnvStr = s
  389. End Function
  390.  
  391. Function PointerToString(p As Long) As String
  392.     Dim c As Long
  393.     c = lstrlenPtr(p)
  394.     PointerToString = String$(c, 0)
  395.     If UnicodeTypeLib Then
  396.         CopyMemoryToStr PointerToString, ByVal p, c * 2
  397.     Else
  398.         CopyMemoryToStr PointerToString, ByVal p, c
  399.     End If
  400. End Function
  401.  
  402. Function StringToPointer(s As String) As Long
  403.     If UnicodeTypeLib Then
  404.         StringToPointer = VarPtr(s)
  405.     Else
  406.         StringToPointer = StrPtr(s)
  407.     End If
  408. End Function
  409.  
  410. Sub SaveFileStr(sFile As String, sContent As String)
  411.     Dim nFile As Integer
  412.     nFile = FreeFile
  413.     Open sFile For Output Access Write Lock Write As nFile
  414.     Print #nFile, sContent;
  415.     Close nFile
  416. End Sub
  417.  
  418. Function SaveFileText(sFileName As String, sText As String) As Long
  419.     Dim nFile As Integer
  420.     On Error Resume Next
  421.     nFile = FreeFile
  422.     Open sFileName For Output Access Write Lock Write As nFile
  423.     Print #nFile, sText
  424.     Close nFile
  425.     SaveFileText = Err
  426. End Function
  427.  
  428. Function FindString(sTarget As String, sFind As String, _
  429.                     Optional ByVal iPos As Long, _
  430.                     Optional ByVal esoOptions As ESearchOptions) As Long
  431.     Dim ordComp As Long, cFind As Long, fBack As Boolean
  432.     ' Get the compare method
  433.     If esoOptions And esoCaseSense Then
  434.         ordComp = vbBinaryCompare
  435.     Else
  436.         ordComp = vbTextCompare
  437.     End If
  438.     ' Set up first search
  439.     cFind = Len(sFind)
  440.     If iPos = 0 Then iPos = 1
  441.     If esoOptions And esoBackward Then fBack = True
  442.     Do
  443.         ' Find the string
  444.         If fBack Then
  445.             iPos = InStrR(iPos, sTarget, sFind, ordComp)
  446.         Else
  447.             iPos = InStr(iPos, sTarget, sFind, ordComp)
  448.         End If
  449.         ' If not found, we're done
  450.         If iPos = 0 Then Exit Function
  451.         If esoOptions And esoWholeWord Then
  452.             ' If it's supposed to be whole word and is, we're done
  453.             If IsWholeWord(sTarget, iPos, Len(sFind)) Then Exit Do
  454.             ' Otherwise, set up next search
  455.             If fBack Then
  456.                 iPos = iPos - cFind
  457.                 If iPos < 1 Then Exit Function
  458.             Else
  459.                 iPos = iPos + cFind
  460.                 If iPos > Len(sTarget) Then Exit Function
  461.             End If
  462.         Else
  463.             ' If it wasn't a whole word search, we're done
  464.             Exit Do
  465.         End If
  466.     Loop
  467.     FindString = iPos
  468. End Function
  469.  
  470. Private Function IsWholeWord(sTarget As String, ByVal iPos As Long, _
  471.                              ByVal cFind As Long) As Boolean
  472.     Dim sChar As String, sSep As String
  473.     sSep = " .,!:?" & sTab & sCrLf
  474.     ' Check character before
  475.     If iPos > 1 Then
  476.         sChar = Mid$(sTarget, iPos - 1, 1)
  477.         If InStr(sSep, sChar) = 0 Then Exit Function
  478.     End If
  479.     ' Check character after
  480.     If iPos < Len(sTarget) - 1 Then
  481.         sChar = Mid$(sTarget, iPos + cFind, 1)
  482.         If InStr(sSep, sChar) = 0 Then Exit Function
  483.     End If
  484.     IsWholeWord = True
  485. End Function
  486.  
  487. ' Basic is one of the few languages where you can't extract a character
  488. ' from or insert a character into a string at a given position without
  489. ' creating another string. These procedures fix that limitation.
  490.  
  491. ' Much faster than AscW(Mid$(sTarget, iPos, 1))
  492. Function CharFromStr(sTarget As String, _
  493.                      Optional ByVal iPos As Long = 1) As Integer
  494.     CopyMemory CharFromStr, ByVal StrPtr(sTarget) + (iPos * 2) - 2, 2
  495. End Function
  496.  
  497. ' Much faster than Mid$(sTarget, iPos, 1) = Chr$(ch)
  498. Sub CharToStr(sTarget As String, ByVal ch As Integer, _
  499.               Optional ByVal iPos As Long = 1)
  500.     CopyMemory ByVal StrPtr(sTarget) + (iPos * 2) - 2, ch, 2
  501. End Sub
  502.  
  503. ' This brute force algorithm should be replaced with the Boyer-Moore
  504. ' algrorithm or some other sophisticated string search code
  505. Function InStrR(Optional vStart As Variant, _
  506.                 Optional vTarget As Variant, _
  507.                 Optional vFind As Variant, _
  508.                 Optional vCompare As Variant) As Long
  509.     If IsMissing(vStart) Then ErrRaise eeMissingParameter
  510.     
  511.     ' Handle missing arguments
  512.     Dim iStart As Long, sTarget As String
  513.     Dim sFind As String, ordCompare As Long
  514.     If VarType(vStart) = vbString Then
  515.         BugAssert IsMissing(vCompare)
  516.         If IsMissing(vTarget) Then ErrRaise eeMissingParameter
  517.         sTarget = vStart
  518.         sFind = vTarget
  519.         iStart = Len(sTarget)
  520.         If IsMissing(vFind) Then
  521.             ordCompare = vbBinaryCompare
  522.         Else
  523.             ordCompare = vFind
  524.         End If
  525.     Else
  526.         If IsMissing(vTarget) Or IsMissing(vFind) Then
  527.             ErrRaise eeMissingParameter
  528.         End If
  529.         sTarget = vTarget
  530.         sFind = vFind
  531.         iStart = vStart
  532.         If IsMissing(vCompare) Then
  533.             ordCompare = vbBinaryCompare
  534.         Else
  535.             ordCompare = vCompare
  536.         End If
  537.     End If
  538.     
  539.     ' Search backward
  540.     Dim cFind As Long, i As Long, f As Long
  541.     cFind = Len(sFind)
  542.     For i = iStart - cFind + 1 To 1 Step -1
  543.         If StrComp(Mid$(sTarget, i, cFind), sFind, ordCompare) = 0 Then
  544.             InStrR = i
  545.             Exit Function
  546.         End If
  547.     Next
  548. End Function
  549.  
  550.  
  551. Function PlayWave(ab() As Byte, Optional Flags As Long = _
  552.                                 SND_MEMORY Or SND_SYNC) As Boolean
  553.     PlayWave = sndPlaySoundAsBytes(ab(0), Flags)
  554. End Function
  555.  
  556. Sub InsertChar(sTarget As String, sChar As String, iPos As Integer)
  557.     BugAssert Len(sChar) = 1        ' Accept characters only
  558.     BugAssert iPos > 0              ' Don't insert before beginning
  559.     BugAssert iPos <= Len(sTarget)  ' Don't insert beyond end
  560.     Mid$(sTarget, iPos, 1) = sChar  ' Do work
  561. End Sub
  562.  
  563. Function LineWrap(sText As String, cMax As Integer)
  564.     Dim s As String, i As Integer, iLast As Integer, c As Integer
  565.     c = Len(sText)
  566.     i = 1
  567.     Do While c
  568.         iLast = i
  569.         i = i + cMax
  570.         Do While Mid$(sText, i, 1) <> sSpace
  571.             i = i - 1
  572.         Loop
  573.         s = s & Mid$(sText, iLast, i - iLast) & sCrLf & "   "
  574.         i = i + 1
  575.     Loop
  576.     LineWrap = s
  577. End Function
  578.  
  579. ' Pascal:    if ch in ['a', 'f', 'g'] then
  580. ' Basic:     If Among(ch, "a", "f", "g") Then
  581. Function Among(vTarget As Variant, ParamArray A() As Variant) As Boolean
  582.     Among = True    ' Assume found
  583.     Dim v As Variant
  584.     For Each v In A()
  585.         If v = vTarget Then Exit Function
  586.     Next
  587.     Among = False
  588. End Function
  589.  
  590. ' Work around limitation of AddressOf
  591. '    Call like this: procVar = GetProc(AddressOf ProcName)
  592. Function GetProc(proc As Long) As Long
  593.     GetProc = proc
  594. End Function
  595.  
  596. Function WordWrap(sText As String, ByVal cMax As Long) As String
  597.     Dim iStart As Long, iEnd As Long, cText As Long, sSep As String
  598.     cText = Len(sText)
  599.     iStart = 1
  600.     iEnd = cMax
  601.     sSep = " " & sTab & sCrLf
  602.     Do While iEnd < cText
  603.         ' Parse back to white space
  604.         Do While InStr(sSep, Mid$(sText, iEnd, 1)) = 0
  605.             iEnd = iEnd - 1
  606.             ' Don't send us text with words longer than the lines!
  607.             If iEnd <= iStart Then
  608.                 WordWrap = sText
  609.                 Exit Function
  610.             End If
  611.         Loop
  612.         WordWrap = WordWrap & Mid$(sText, iStart, iEnd - iStart + 1) & sCrLf
  613.         iStart = iEnd + 1
  614.         iEnd = iStart + cMax
  615.     Loop
  616.     WordWrap = WordWrap + Mid$(sText, iStart)
  617. End Function
  618.  
  619.  
  620. Sub CollectionReplace(n As Collection, vIndex As Variant, _
  621.                       vVal As Variant)
  622.     If VarType(vIndex) = vbString Then
  623.         n.Remove vIndex
  624.         n.Add vVal, vIndex
  625.     Else
  626.         n.Add vVal, , vIndex
  627.         n.Remove vIndex + 1
  628.     End If
  629. End Sub
  630.  
  631. Function GetLabel(sRoot As String) As String
  632.     GetLabel = Dir$(sRoot & "*.*", vbVolume)
  633. End Function
  634.  
  635. Function GetFileBase(sFile As String) As String
  636.     Dim iBase As Long, iExt As Long, s As String
  637.     If sFile = sEmpty Then Exit Function
  638.     s = GetFullPath(sFile, iBase, iExt)
  639.     GetFileBase = Mid$(s, iBase, iExt - iBase)
  640. End Function
  641.  
  642. Function GetFileBaseExt(sFile As String) As String
  643.     Dim iBase As Long, s As String
  644.     If sFile = sEmpty Then Exit Function
  645.     s = GetFullPath(sFile, iBase)
  646.     GetFileBaseExt = Mid$(s, iBase)
  647. End Function
  648.  
  649. Function GetFileExt(sFile As String) As String
  650.     Dim iExt As Long, s As String
  651.     If sFile = sEmpty Then Exit Function
  652.     s = GetFullPath(sFile, , iExt)
  653.     GetFileExt = Mid$(s, iExt)
  654. End Function
  655.  
  656. Function GetFileDir(sFile As String) As String
  657.     Dim iBase As Long, s As String
  658.     If sFile = sEmpty Then Exit Function
  659.     s = GetFullPath(sFile, iBase)
  660.     GetFileDir = Left$(s, iBase - 1)
  661. End Function
  662.  
  663. Function GetFileFullSpec(sFile As String) As String
  664.     If sFile = sEmpty Then Exit Function
  665.     GetFileFullSpec = GetFullPath(sFile)
  666. End Function
  667.  
  668. Function SearchForExe(sName As String) As String
  669.     Dim sSpec As String, asExt(1 To 5) As String, i As Integer
  670.     asExt(1) = ".EXE": asExt(2) = ".COM": asExt(3) = ".PIF":
  671.     asExt(4) = ".BAT": asExt(5) = ".CMD"
  672.     For i = 1 To 5
  673.         sSpec = SearchDirs(sName, asExt(i))
  674.         If sSpec <> sEmpty Then Exit For
  675.     Next
  676.     SearchForExe = sSpec
  677. End Function
  678.  
  679. Function IsExe() As Boolean
  680.     Dim sExe  As String, c As Long
  681.     sExe = String$(255, 0)
  682.     c = GetModuleFileName(hNull, sExe, 255)
  683.     sExe = Left$(sExe, c)
  684.     IsExe = Right$(UCase$(sExe), 7) <> "VB5.EXE"
  685. End Function
  686.  
  687. Function xRight(obj As Object) As Single
  688.     xRight = obj.Left + obj.Width
  689. End Function
  690.  
  691. Function yBottom(obj As Object) As Single
  692.     yBottom = obj.Top + obj.Height
  693. End Function
  694.  
  695. ' Win32 functions with Basic interface
  696.  
  697. ' GetFullPath - Basic version of Win32 API emulation routine. It returns a
  698. ' BSTR, and indexes to the file name, directory, and extension parts of the
  699. ' full name.
  700. '
  701. ' Input:  sFileName - file to be qualified in one of these formats:
  702. '
  703. '              [relpath\]file.ext
  704. '              \[path\]file.ext
  705. '              .\[path\]file.ext
  706. '              d:\[path\]file.ext
  707. '              ..\[path\]file.ext
  708. '              \\server\machine\[path\]file.ext
  709. '          iName - variable to receive file name position
  710. '          iDir - variable to receive directory position
  711. '          iExt - variable to receive extension position
  712. '
  713. ' Return: Full path name, or an empty string on failure
  714. '
  715. ' Errors: Any of the following:
  716. '              ERROR_BUFFER_OVERFLOW      = 111
  717. '              ERROR_INVALID_DRIVE        = 15
  718. '              ERROR_CALL_NOT_IMPLEMENTED = 120
  719. '              ERROR_BAD_PATHNAME         = 161
  720.  
  721.  
  722. Function GetFullPath(sFileName As String, _
  723.                      Optional FilePart As Long, _
  724.                      Optional ExtPart As Long, _
  725.                      Optional DirPart As Long) As String
  726.  
  727.     Dim c As Long, p As Long, sRet As String
  728.     If sFileName = sEmpty Then Exit Function
  729.     
  730.     ' Get the path size, then create string of that size
  731.     sRet = String(cMaxPath, 0)
  732.     c = GetFullPathName(sFileName, cMaxPath, sRet, p)
  733.     If c = 0 Then ApiRaise Err.LastDllError
  734.     BugAssert c <= cMaxPath
  735.     sRet = Left$(sRet, c)
  736.  
  737.     ' Get the directory, file, and extension positions
  738.     GetDirExt sRet, FilePart, DirPart, ExtPart
  739.     GetFullPath = sRet
  740.     
  741. End Function
  742.  
  743. Function GetTempFile(Optional Prefix As String, _
  744.                      Optional PathName As String) As String
  745.     
  746.     If Prefix = sEmpty Then Prefix = sEmpty
  747.     If PathName = sEmpty Then PathName = GetTempDir
  748.     
  749.     Dim sRet As String
  750.     sRet = String(cMaxPath, 0)
  751.     GetTempFileName PathName, Prefix, 0, sRet
  752.     ApiRaiseIf Err.LastDllError
  753.     GetTempFile = GetFullPath(StrZToStr(sRet))
  754. End Function
  755.  
  756. Function GetTempDir() As String
  757.     Dim sRet As String, c As Long
  758.     sRet = String(cMaxPath, 0)
  759.     c = GetTempPath(cMaxPath, sRet)
  760.     If c = 0 Then ApiRaise Err.LastDllError
  761.     GetTempDir = Left$(sRet, c)
  762. End Function
  763.  
  764. Function SearchDirs(sFileName As String, _
  765.                     Optional Ext As String, _
  766.                     Optional Path As String, _
  767.                     Optional FilePart As Long, _
  768.                     Optional ExtPart As Long, _
  769.                     Optional DirPart As Long) As String
  770.  
  771.     Dim p As Long, c As Long, sRet As String
  772.  
  773.     If sFileName = sEmpty Then ApiRaise ERROR_INVALID_PARAMETER
  774.  
  775.     ' Handle missing or invalid extension or path
  776.     If Ext = sEmpty Then Ext = sNullStr
  777.     If Path = sEmpty Then Path = sNullStr
  778.     
  779.     ' Get the file (treating empty strings as NULL pointers)
  780.     sRet = String$(cMaxPath, 0)
  781.     c = SearchPath(Path, sFileName, Ext, cMaxPath, sRet, p)
  782.     If c = 0 Then
  783.         If Err.LastDllError = ERROR_FILE_NOT_FOUND Then Exit Function
  784.         ApiRaise Err.LastDllError
  785.     End If
  786.     BugAssert c <= cMaxPath
  787.     sRet = Left$(sRet, c)
  788.  
  789.     ' Get the directory, file, and extension positions
  790.     GetDirExt sRet, FilePart, DirPart, ExtPart
  791.     SearchDirs = sRet
  792.    
  793. End Function
  794.  
  795. Private Sub GetDirExt(sFull As String, iFilePart As Long, _
  796.                       iDirPart As Long, iExtPart As Long)
  797.  
  798.     Dim iDrv As Integer, i As Integer, cMax As Integer
  799.     cMax = Len(sFull)
  800.  
  801.     iDrv = Asc(UCase$(Left$(sFull, 1)))
  802.  
  803.     ' If in format d:\path\name.ext, return 3
  804.     If iDrv <= 90 Then                          ' Less than Z
  805.         If iDrv >= 65 Then                      ' Greater than A
  806.             If Mid$(sFull, 2, 1) = ":" Then     ' Second character is :
  807.                 If Mid$(sFull, 3, 1) = "\" Then ' Third character is \
  808.                     iDirPart = 3
  809.                 End If
  810.             End If
  811.         End If
  812.     Else
  813.  
  814.         ' If in format \\machine\share\path\name.ext, return position of \path
  815.         ' First and second character must be \
  816.         If iDrv <> 92 Then ApiRaise ERROR_BAD_PATHNAME
  817.         If Mid$(sFull, 2, 1) <> "\" Then ApiRaise ERROR_BAD_PATHNAME
  818.  
  819.         Dim fFirst As Boolean
  820.         i = 3
  821.         Do
  822.             If Mid$(sFull, i, 1) = "\" Then
  823.                 If Not fFirst Then
  824.                     fFirst = True
  825.                 Else
  826.                     iDirPart = i
  827.                     Exit Do
  828.                 End If
  829.             End If
  830.             i = i + 1
  831.         Loop Until i = cMax
  832.     End If
  833.  
  834.     ' Start from end and find extension
  835.     iExtPart = cMax + 1       ' Assume no extension
  836.     fFirst = False
  837.     Dim sChar As String
  838.     For i = cMax To iDirPart Step -1
  839.         sChar = Mid$(sFull, i, 1)
  840.         If Not fFirst Then
  841.             If sChar = "." Then
  842.                 iExtPart = i
  843.                 fFirst = True
  844.             End If
  845.         End If
  846.         If sChar = "\" Then
  847.             iFilePart = i + 1
  848.             Exit For
  849.         End If
  850.     Next
  851.     Exit Sub
  852. FailGetDirExt:
  853.     iFilePart = 0
  854.     iDirPart = 0
  855.     iExtPart = 0
  856. End Sub
  857.  
  858. #If fComponent Then
  859. ' Seed the component's copy of the random number generator
  860. Sub CoreRandomize(Optional Number As Long)
  861.     Randomize Number
  862. End Sub
  863.  
  864. Function CoreRnd(Optional Number As Long)
  865.     CoreRnd = Rnd(Number)
  866. End Function
  867. #End If
  868.  
  869. ' GetNextLine returns a line from a string, where a "line" is all characters
  870. ' up to and including a carriage return + line feed. GetNextLine
  871. ' works the same way as GetToken. The first call to GetNextLine
  872. ' should pass the string to parse; subsequent calls should pass
  873. ' an empty string. GetNextLine returns an empty string after all lines
  874. ' have been read from the source string.
  875. Function GetNextLine(Optional sSource As String) As String
  876.     Static sSave As String, iStart As Long, cSave As Long
  877.     Dim iEnd As Long
  878.     
  879.     ' Initialize GetNextLine
  880.     If (sSource <> sEmpty) Then
  881.         iStart = 1
  882.         sSave = sSource
  883.         cSave = Len(sSave)
  884.     Else
  885.         If sSave = sEmpty Then Exit Function
  886.     End If
  887.     
  888.     ' iStart points to first character after the previous sCrLf
  889.     iEnd = InStr(iStart, sSave, sCrLf)
  890.     
  891.     If iEnd > 0 Then
  892.         ' Return line
  893.         GetNextLine = Mid$(sSave, iStart, iEnd - iStart + 2)
  894.         iStart = iEnd + 2
  895.         If iStart > cSave Then sSave = sEmpty
  896.     Else
  897.         ' Return remainder of string as a line
  898.         GetNextLine = Mid$(sSave, iStart) & sCrLf
  899.         sSave = sEmpty
  900.     End If
  901. End Function
  902.  
  903. ' RTrimLine strips off trailing carriage return + line feed
  904. Function RTrimLine(sLine As String) As String
  905.     If Right$(sLine, 2) = sCrLf Then
  906.         RTrimLine = Left$(sLine, Len(sLine) - 2)
  907.     Else
  908.         RTrimLine = sLine
  909.     End If
  910. End Function
  911.  
  912.  
  913.  
  914.